{-- 
    Conversions between external, meta and internal data structures
    
    Used in import to translate annotation data to types and expressions.
    
    The parts play together like this for 'Expr's
    
    1. In GenMeta, items for export are selected. This are
    functions from the @inline@ pragma and default class operations.
    
    2. The expressions of those symbols are serialized into 'E.ExprA' form.
    
    3. The serialized expressions are written to the Java file as annotations,
    using the annotation interface type 'CT.Expr',
    which is isomorphic with 'ExprA'.
    
    4. On import, the 'CT.Expr's first will be translated back to 'E.ExprA'.
    
    5. The imported symbols with expressions get a state transformer
    in their 'Symbol.expr' field that reconstructs a normal 'Expr' from 'ExprA'.
    In this way, inlineable or reusable expressions do not contain
    'Local' variables with @uid@s that are meaningless outside of
    their context.
    
    6. In build mode, we want to re-use the symbol table of compiled modules,
    without first java compiling them and then loading the class file.
    Hence, in this case, we also put the state transformer in the symbols
    after code generation.
    This way the symbol table appears like one that was just reconstructed
    from class files.  
-}

module frege.compiler.common.ImpExp 
        inline (maybeQN, ctContext, ctTau, ctSigma)
    where

import Compiler.types.External as E
import Compiler.Classtools as CT()
import Compiler.types.Expression
import Compiler.types.Patterns
import Compiler.types.Types
import Compiler.types.Positions
import Compiler.types.QNames
import Compiler.types.Packs
import Compiler.types.Global
import Compiler.enums.SymState
import Compiler.types.Strictness
import Compiler.Utilities as U()
import Compiler.common.SymbolTable
import Compiler.common.Errors as Err()
import Compiler.classes.Nice(nice)
import Lib.PP(text, <>)

--- rebuild a 'QName' from meta form
rebuildQN :: CT.QName -> QName
rebuildQN qn = case qn.kind of
    0 -> tname
    1 -> VName (Pack.new qn.pack) qn.base
    2 -> MName tname qn.member
    k -> error ("illegal QName kind in CT:QName " ++ show (k, (qn.pack, qn.base, qn.member)))
  where
    tname = TName (Pack.new qn.pack) qn.base

--- reconstruct a 'Kind' from a 'KindA'
kindFromA :: TauA -> JArray TauA -> JArray Tau -> Kind
kindFromA ka karray tarray = case ka.kind of
        8 -> KApp (kfrom ka.suba) (kfrom ka.subb)
        9  -> KType
        10 -> KType
        11 -> KGen [elemAt tarray ka.suba]
        12 -> KGen [elemAt tarray ka.suba, elemAt tarray ka.subb]
        13 -> case kfrom ka.subb of
                KGen list → KGen (elemAt tarray ka.suba:list)
                _ -> error ("bad KGen chain" ++ show ka.subb)
        k -> error ("illegal kind " ++ show k ++ " in KindA")
    where
        kfrom k = kindFromA (karray.[k]) karray tarray


--- get a 'QName' from a 'CT.QNameArr', if possible
maybeQN :: CT.QNameArr -> Maybe QName
maybeQN qna = if qna.length == 0 
                then Nothing
                else (Just . rebuildQN . elemAt qna) 0 

--- translate a 'CT.Tau' to a 'TauA'
ctTau :: CT.Tau -> TauA
ctTau ct = TauA{kind=ct.kind, tcon=maybeQN ct.tcon, 
                    suba=ct.suba, subb=ct.subb, tvar=ct.tvar}

--- reconstruct a 'Tau' from a 'TauA'
tauFromA :: JArray TauA -> TauA -> JArray Tau -> Tau
tauFromA karray ta tarray = case ta.kind of
        0 -> tapp
        1 -> tfun
        2 | Just qn <- ta.tcon = TCon pos qn
        3 -> TVar pos (kindFromA karray.[ta.suba] karray tarray) ta.tvar
        k | k>=8, k<=13 = TVar pos KType "?"
          | otherwise = error ("illegal tau kind " ++ show k ++ " in tau")
    where
        pos  = Position.null
        tapp = TApp     (elemAt tarray ta.suba) (elemAt tarray ta.subb) 
        tfun = Tau.tfun (elemAt tarray ta.suba) (elemAt tarray ta.subb) 

--- translate a 'CT.Context' to a 'ContextA'
ctContext :: CT.Context -> ContextA
ctContext ct = CtxA{clas=rebuildQN ct.clas, tau=ct.tau}

ctxFromA :: JArray Tau -> ContextA -> Context
ctxFromA tarray CtxA{clas, tau} 
    = Ctx{pos=Position.null, cname = clas, tau = tarray.[tau]}

--- translate a 'CT.Rho' to a 'RhoA'
ctRho :: CT.Rho -> RhoA
ctRho ct = RhoA{rhofun=ct.rhofun, 
                cont  = [ ctContext cx | cx <- ct.cont ], 
                sigma =ct.sigma, 
                rhotau=ct.rhotau}                
                
--- reconstruct a 'Rho' from a 'RhoA'
--- At this point we don't have a sigma array yet, hence we use an array of 'SigmaA'
rhoFromA :: JArray TauA -> JArray Tau -> JArray SigmaA -> RhoA -> JArray Rho -> Rho
rhoFromA karray tarray sarray ra rarray = case ra of
        RhoA{rhofun=false} = RhoTau{context, tau}
        RhoA{rhofun=true}  = RhoFun{context, sigma, rho}
    where
        context = map (ctxFromA tarray) ra.cont
        tau     = tarray.[ra.rhotau]
        rho     = rarray.[ra.rhotau]
        sigma   = sigmaFromA karray tarray rarray sarray.[ra.sigma] 

--- translate a 'CT.Sigma' to a 'SigmaA'
ctSigma :: CT.Sigma -> SigmaA
ctSigma ct = SigmaA{bound=toList ct.bound, kinds=listFromArray ct.kinds, rho=ct.rho}

{-- 
    reconstruct a 'Sigma' from a 'RhoA'

    Because 'RhoA' reference the sigma table and 'SigmaA' reference
    the rho table, we never build a 'Sigma' array.
-}
sigmaFromA :: JArray TauA -> JArray Tau -> JArray Rho -> SigmaA -> Sigma
sigmaFromA karray tarray rarray SigmaA{bound, kinds, rho} 
    = ForAll 
        (zipWith 
            (\var kind -> TVar{pos=Position.null, var, kind}) 
            bound 
            (map kind kinds)) 
        rarray.[rho]
        where
            kind k = kindFromA karray.[k] karray tarray
    
--- translate a 'CT.Expr' to an 'ExprA'
ctExpr :: CT.Expr -> ExprA
ctExpr ct = ExprA{xkind  = ct.xkind, 
                    name = maybeQN ct.name, 
                    lkind = ct.lkind, 
                    varval = if null ct.varval then Nothing else Just ct.varval, 
                    alts = listFromArray ct.alts, 
                    subx1 = ct.subx1, 
                    subx2 = ct.subx2, 
                    subx3 = ct.subx3}
{---
    reconstruct an 'Expr' from a 'ExprA'
    -}
exprFromA :: JArray Sigma -> JArray ExprA -> ExprA -> StG Expr 
exprFromA  sarray earray exa = case exa.xkind of
            0 -> do
                ex <- xref exa.subx1
                pure Ann {ex, typ = Just (nSigma exa.lkind)}
            1 -> do
                x1 <- xref exa.subx1
                x2 <- xref exa.subx2
                pure (App x1 x2 Nothing)
            2 -> do
                alts <- mapSt calt (zip pats exps)
                ex   <- xref exa.subx1
                pure Case {ckind = from exa.lkind, ex,
                            typ = Nothing, alts}
            3 | Just qn <- exa.name = stio Con {pos = Position.null, typ = Nothing, name = qn}
            4 -> do
                x1 <- xref exa.subx1
                x2 <- xref exa.subx2
                x3 <- xref exa.subx3
                pure (Ifte x1 x2 x3 Nothing)
            5 -> do
                alts <- mapSt calt (zip pats exps)
                let alt = head alts
                pure Lam {pat = alt.pat, ex = alt.ex, typ = Nothing}
            6 | Just s  <- exa.varval = pure Lit {pos=Position.null, typ=Nothing, 
                                                  kind = from (abs exa.lkind), value = s,
                                                  negated = exa.lkind < 0}
            7                         = pure Vbl {pos=Position.null, typ=Nothing, name = Local 0 ("v" ++ show exa.subx1)}
            8 | Just qn <- exa.name   = pure Vbl {pos=Position.null, typ=Nothing, name = qn}
            9                         = mklet (triples exa.alts) exa.subx1
            w -> error ("bad expra id: " ++ show w)
    where
        nSigma n = sarray.[n]
        x0 = exa.alts.length `quot` 2
        pats = map pref (take x0 exa.alts)
        exps = map xref (drop x0 exa.alts)
        calt (dpat, dex) = do
                pat <- dpat
                ex  <- dex
                pat <- U.pReturn pat        -- make sure it has numbers
                syms <- mapSt U.mkLocal (patVars pat)
                mkStrictPVars pat
                ex <- U.mapEx true (U.replaceLocals syms) ex
                stio CAlt {pat, ex}
        triples (a:b:c:xs) = (a,b,c):triples xs
        triples []          = []
        triples xs          = error "list size must be multiple of 3"
        mklet triples body = do
            syms ← mapSt letbound triples
            syms `foreach` 
                \sym → changeSym sym.{
                            expr ← fmap (>>= U.mapEx true (U.replaceLocals syms))}
            ex   ← xref body >>= U.mapEx true (U.replaceLocals syms)
            return Let{env=map Symbol.name syms, ex, typ=Nothing}
        letbound (varix, sigix, rhsix) = do
            pat ← pref varix >>= U.pReturn
            let pvar = patVars pat
            case pvar of 
                [p@PVar{}] → do
                    sym ← U.mkLocal p
                    let bound = sym.{expr = Just (xref rhsix),
                                     typ  = if sigix >= 0 
                                                then nSigma sigix 
                                                else pSigma}
                    changeSym bound
                    return bound
                _ -> do
                    g <- getST
                    Err.fatal (getpos pat) (
                        text "There must be exactly one variable in pattern"
                        <> text (nice pat g))
        mkStrictPVars PCon{pats} = foreach pats mkStrictPVars
        mkStrictPVars PUser{pat,lazy}
            | PVar{pos,uid,var} <- pat = do
                sym <- U.findV (Local {base=var, uid})
                changeSym sym.{state=StrictChecked, strsig=if lazy then U else S[]}
            | otherwise          = mkStrictPVars pat
        mkStrictPVars PAnn{pat}  = mkStrictPVars pat
        mkStrictPVars PAt{pat}   = mkStrictPVars pat
        mkStrictPVars PLit{}     = return ()
        mkStrictPVars PVar{}     = return ()
        mkStrictPVars PMat{}     = return ()
        mkStrictPVars PConFS{}   = undefined
        xref i = exprFromA sarray earray earray.[i]
        x2p :: Expr -> Pattern
        x2p (Vbl {pos, name = Local u n})       = PVar {pos, uid = u, var = n}
        x2p (Lit {pos, kind, value,negated})    = PLit {pos, kind, value, negated}
        x2p (Con {pos, name})                   = PCon {pos, qname = name, pats=[]}
        x2p (Ann {ex,typ=Just sig})             = PAnn {pat = x2p ex, typ = sig}
        x2p (app@App _ _ _) = case map fst (flatx app) of
            (Con {name}:args) -> PCon {pos=Position.null, qname=name, pats = map x2p args}
            [Vbl {name=VName _ "!"}, x] -> PUser {pat=x2p x, lazy = false}
            [Vbl {name=VName _ "?"}, x] -> PUser {pat=x2p x, lazy = true}
            [Vbl {name=VName _ "@"}, v1, v2] -> PAt {pos=Position.null, uid = 0, var=p1.var, pat=p2}
                where p1 = x2p v1; p2 = x2p v2
            [Vbl {name=VName _ "~"}, v1, v2] -> PMat {pos=Position.null, uid = 0, var=p1.var, value}
                where p1 = x2p v1; value = v2.value
            sonst -> error ("x2p: illegal expr ")
        x2p ex = error("x2p: illegal expr ")
        pref i = xref i >>= return . x2p 
